Исходный текст

Option Explicit
Call WorkWithObjectsCol(ThisApplication.Desktop.Objects)



'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией объектов
'==============================================================================
Sub WorkWithObjectsCol(ObjCol)
        'Если коллекция пустая, закончить работу сразу
        If ObjCol.Count=0 Then
                MsgBox "Передана пустая коллекция.", vbExclamation
                Exit Sub
        End If
        
        Dim SelDlg, RetVal, strAction, ArActions
        
        ArActions = Array("Создать объект", "Переместить объект", "Отобрать подмножество",_
                                 "Удалить объект", "Очистить коллекцию")
        
        'Предоставить пользователю выбрать действие 
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArActions 
        SelDlg.Prompt = "Выберите действие:"
        RetVal = SelDlg.Show
        
        'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
        'Диалог вернул массив, поскольку был инициализирован строковым массивом
        If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'Выполнить все заданные действия
        For Each strAction In SelDlg.Objects
                If StrComp(strAction, ArActions(0))=0 Then
                                                                                            Call CreateObject(ObjCol)
                ElseIf StrComp(strAction, ArActions(1))=0 Then
                                                                                            Call MoveObject(ObjCol, SelDlg, 0)
                ElseIf StrComp(strAction, ArActions(2))=0 Then
                                                                                            Call GetSubCol(ObjCol)
                ElseIf StrComp(strAction, ArActions(3))=0 Then
                                                                                            Call RemoveObject(ObjCol, SelDlg)
                ElseIf StrComp(strAction, ArActions(4))=0 Then
                                                                                            Call EmptyCol(ObjCol)
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Создать новый    объект выбранного типа в коллекции (на Рабочем столе). 
'==============================================================================
Sub CreateObject(ObjCol)
        Dim SelDlg, RetVal, ArSize, ArObjDefs, ObjDef, NewObj, i
        
        'Заполнить массив ссылками на Типы объектов, созданные в приложении
        ArSize = ThisApplication.ObjectDefs.Count
        
        ReDim ArObjDefs(ArSize)
        For i=0 To ArSize-1
                Set ArObjDefs(i) = ThisApplication.ObjectDefs(i)
        Next
        
        'Открыть диалог выбора, передав на вход массив Типов объектов
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArObjDefs
        SelDlg.Caption = "Типы объектов"
        SelDlg.Prompt = "Выберите тип(ы) объекта для создания новых экземпляров в коллекции:"
        RetVal = SelDlg.Show
        
        'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
        If (Not RetVal) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'Отключить обработку ошибок (они могут возникнуть при создании объекта)
        On Error Resume Next
        
        'Создать новые объекты выбранных типов.
        For Each ObjDef In SelDlg.Objects
                    
                    'Внимание: при вызове метода Create будут генерироваться события ObjectBeforeCreate, 
                    'ObjectCreated
                    Set NewObj = ObjCol.Create(ObjDef)
                    NewObj.Description = "Created from " & ObjDef.Description
                    
                    'Если ошибка все-таки была, удалить созданный объект чтобы не мусорить...
                    If Err<>0 Then
                            MsgBox "Ошибка создания объекта типа """ & ObjDef.Description & """" & Chr(13) &_
                                         "(код ошибки " & Err &").", vbExclamation
                            Err=0 'обнулить ошибку, чтобы можно было дальше работать...
                            If Not (NewObj Is Nothing) Then NewObj.Erase
                    End If
        Next
        
        'Обновить интерфейс, чтобы полюбоваться на созданные объекты
        ThisApplication.Shell.Update(ThisApplication.Desktop)
End Sub
'==============================================================================


'==============================================================================
'Переместить выбранный объект на нулевую позицию
'==============================================================================
Sub MoveObject(ObjCol, SelDlg, position)
        Dim RetVal
        
        'Дать пользователю возможность выбрать объект для перемещения
        SelDlg.SelectFrom = ObjCol
        SelDlg.Caption = "Объекты в коллекции"
        SelDlg.Prompt = "Выберите объект для перемещения в начало:"
        RetVal = SelDlg.Show
        
        'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
        If (Not RetVal) Or (SelDlg.Objects.Count=0) Then Exit Sub
        
        'Переместить объект (первый из выбранных, если их было несколько)
        ObjCol.Move SelDlg.Objects(0), position
        'Применение методов Swap, Move требует явного обновления коллекции, иначе
        'изменения будут потеряны!
        ObjCol.Update
                        
        'Обновить интерфейс
        ThisApplication.Shell.Update(ThisApplication.Desktop)
End Sub
'==============================================================================


'==============================================================================
'Сообщить, сколько объектов указанного типа содержится в коллекции
'==============================================================================
Sub GetSubCol(ObjCol)
        Dim SelDlg, RetVal, ArSize, ArObjDefs, ObjDef, StrInfo, i, SubCol
        
        'Заполнить массив ссылками на Типы объектов, созданные в приложении
        ArSize = ThisApplication.ObjectDefs.Count
        
        ReDim ArObjDefs(ArSize)
        For i=0 To ArSize-1
                Set ArObjDefs(i) = ThisApplication.ObjectDefs(i)
        Next
        
        'Открыть диалог выбора, передав на вход массив Типов объектов
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArObjDefs
        SelDlg.Caption = "Типы объектов"
        SelDlg.Prompt = "Выберите тип(ы) объекта для создания новых экземпляров в коллекции:"
        RetVal = SelDlg.Show
        
        'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
        If (Not RetVal) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'Сообщить количество объектов в каждом "подмножестве"
        For Each ObjDef In SelDlg.Objects
                'Полусить ссылку на подмножество объектов данного типа
                Set SubCol = ObjCol.ObjectsByDef(ObjDef)
                'Добавить строку в сообщение
                StrInfo = StrInfo & "Объектов типа """ & ObjDef.Description &_
                                """: " & SubCol.Count & Chr(13)
        Next
        
        'Вывести информацию в окно сообщений
        ThisApplication.AddNotify StrInfo
End Sub
'==============================================================================


'==============================================================================
'Удалить объект из коллекции
'==============================================================================
Sub RemoveObject(ObjCol, SelDlg)
        Dim RetVal, obj 
        
        'Дать пользователю возможность выбрать объект для перемещения
        SelDlg.SelectFrom = ObjCol
        SelDlg.Caption = "Объекты в коллекции"
        SelDlg.Prompt = "Выберите объект для удаления:"
        RetVal = SelDlg.Show
        
        'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
        If (Not RetVal) Or (SelDlg.Objects.Count=0) Then Exit Sub
        
        'Отключить обработку ошибок (они могут возникнуть при удалении)
        On Error Resume Next
        
        'Собственно удаление перечисленных объектов из коллекции 
        '(они при этом продолжают существовать в базе)
        For Each obj In SelDlg.Objects
                        ObjCol.Remove obj 
        
                        'Если ошибка была....
                        If Err<>0 Then
                                MsgBox "Ошибка удаления объекта """ & obj.Description & """." & Chr(13) &_
                                                "Код ошибки: " & Err, vbExclamation     
                        End If        
                        
                        'Обнулить ошибку
                        Err=0
        Next
        
        'Обновить интерфейс
        ThisApplication.Shell.Update(ThisApplication.Desktop)
End Sub
'==============================================================================


'==============================================================================
'Очистить коллекцию (удалить все объекты с Рабочего стола). Объекты остаются в базе
'==============================================================================
Sub EmptyCol(ObjCol)
        Dim RetVal
        
        RetVal =     MsgBox("Очистить коллекцию?", vbQuestion + vbYesNo)    
        If RetVal <> vbNo Then
                ObjCol.RemoveAll
        End If        
        
        'Обновить интерфейс
        ThisApplication.Shell.Update(ThisApplication.Desktop)
End Sub
'==============================================================================